perm filename UNITRE.NEW[1,JRA]1 blob
sn#026672 filedate 1973-02-27 generic text, type T, neo UTF8
(DEFPROP UNITRES
(LAMBDA(C UP UN)
(PROG (C1 Z1 U Z RES)
(SETQ C1 C)
(COND ((AND (ALLPOS C) (NULL UN)) (RETURN NIL)) ((AND (ALLNEG C) (NULL UP)) (RETURN NIL)))
(COND ((NULL UN) (SETQ C (NEGL C)) (GO N)))
(SETQ C (CDR C))
B (SETQ Z1 (CAR C))
(COND ((NEG Z1) (GO N)))
(SETQ U UN)
A (COND ((NOT (EQ (CAR Z1) (CADADR (CAR U)))) (GO A1)))
(SETQ Z (UNI (CDDADR (CAR U)) (CDR Z1) NIL))
(COND ((NULL Z) (GO A1)))
(COND ((NULL Z) (GO A1)) ((UNIT C1) (RETURN (LIST NIL))))
(SETQ RES (CONS (REDUCER C1 C) RES))
(GO A2)
A1 (SETQ U (CDR U))
(COND (U (GO A)))
A2 (SETQ C (CDR C))
(COND (C (GO B)) (T (RETURN RES)))
N (SETQ Z1 (CDAR C))
(SETQ U UP)
C (COND ((NULL U) (RETURN RES)))
C2 (COND ((NOT (EQ (CAR Z1) (CAADAR U))) (GO C1)))
(SETQ Z (UNI (CDADAR U) (CDR Z1) NIL))
(COND ((NULL Z) (GO C1)) ((UNIT C1) (RETURN (LIST NIL))))
(SETQ RES (CONS (REDUCER C1 C) RES))
(GO C3)
C1 (SETQ U (CDR U))
(COND (U (GO C2)))
C3 (SETQ C (CDR C))
(COND (C (GO N)) (T (RETURN RES)))))
EXPR)